home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / bipl.zip / PROGS.ZIP / MAKEPUZZ.ICN < prev    next >
Text File  |  1992-09-28  |  11KB  |  325 lines
  1. ############################################################################
  2. #
  3. #    File:     makepuzz.icn
  4. #
  5. #    Subject:  Program to make find-the-word puzzle
  6. #
  7. #    Author:   Richard L. Goerwitz
  8. #
  9. #    Date:     July 8, 1992
  10. #
  11. ###########################################################################
  12. #
  13. #    Version:  1.19
  14. #
  15. ###########################################################################
  16. #
  17. #     This program doesn't do anything fancy.  It simply takes a list
  18. #  of words, and constructs out of them one of those square
  19. #  find-the-word puzzles that some people like to bend their minds
  20. #  over.  Usage is:
  21. #
  22. #      makepuzz [-f input-file] [-o output-file] [-h puzzle-height]
  23. #         -w puzzle-width] [-t how-many-seconds-to-keep-trying]
  24. #         [-r maximum-number-of-rejects] [-s] [-d]
  25. #
  26. #  where input-file is a file containing words, one to a line
  27. #  (defaults to &input), and ouput-file is the file you would like the
  28. #  puzzle written to (defaults to &output).  Puzzle-height and width
  29. #  are the basic dimensions you want to try to fit your word game into
  30. #  (default 20x20).  If the -s argument is present, makepuzz will
  31. #  scramble its output, by putting random letters in all the blank
  32. #  spaces.  The -t tells the computer when to give up, and construct
  33. #  the puzzle (letting you know if any words didn't make it in).
  34. #  Defaults to 60 (i.e. one minute).  The -r argument tells makepuzz to
  35. #  run until it arrives at a solution with number-of-rejects or less
  36. #  un-inserted words.  -d turns on certain diagnostic messages.
  37. #
  38. #      Most of these options can safely be ignored.  Just type
  39. #  something like "makepuzz -f wordlist," where wordlist is a file
  40. #  containing about sixty words, one word to a line.  Out will pop a
  41. #  "word-find" puzzle.  Once you get the hang of what is going on,
  42. #  try out the various options.
  43. #
  44. #      The algorithm used here is a combination of random insertions
  45. #  and mindless, brute-force iterations through possible insertion
  46. #  points and insertion directions.  If you don't like makepuzz's per-
  47. #  formance on one run, run it again.  If your puzzle is large, try
  48. #  increasing the timeout value (see -t above).
  49. #
  50. ############################################################################
  51. #
  52. #  Links: options, irandom, colmize
  53. #  Requires:  An up-to-date IPL (2/10/92)
  54. #
  55. ############################################################################
  56.  
  57. link options, irandom, colmize
  58. global height, width, _debug_
  59.  
  60. procedure main(a)
  61.  
  62.     local usage, opttbl, inputfile, outputfile, maxrejects, puzzle,
  63.     wordlist, rejects, master_list, word, timeout, x, y, l_puzzle,
  64.     l_wordlist, l_rejects, no_ltrs, l_no_ltrs, try, first_time
  65.  
  66.     # Filename is the only mandatory argument; they can come in any order.
  67.     usage := "makepuzz [-f infile] [-o outfile] [-h height] [-w width] _
  68.     [-t secs] [-r rejects] [-s]"
  69.  
  70.     # Set up puzzle height and width (default 20x20); set up defaults
  71.     # such as the input & output files, time to spend, target reject
  72.     # count, etc.
  73.     opttbl := options(a, "w+h+f:o:t+sr+d") # stop(usage)
  74.     width  := \opttbl["w"] | 20
  75.     height := \opttbl["h"] | 20
  76.     timeout := &time + (1000 * (\opttbl["t"] | 60))
  77.     inputfile := open(\opttbl["f"], "r") | &input
  78.     outputfile := open(\opttbl["o"], "w") | &output
  79.     maxrejects := \opttbl["r"] | 0
  80.     _debug_ := \opttbl["d"] & try := 0
  81.     first_time := 1
  82.  
  83.     # Set random number seed.
  84.     irandom()
  85.  
  86.     # Read, check, and sort word list hardest to easiest.
  87.     master_list := list()
  88.     every word := "" ~== trim(map(!inputfile)) do {
  89.     upto(~(&lcase++&ucase), word) &
  90.         stop("makepuzz:  non-letter found in ", word)
  91.     write(&errout, "makepuzz:  warning, ",3 > *word,
  92.           "-letter word (", word, ")")
  93.     put(master_list, word)
  94.     }
  95.     master_list := sort_words(master_list)
  96.     if \_debug_ then write(&errout, "makepuzz:  thinking...")
  97.  
  98.     # Now, try to insert the words in the master list into a puzzle.
  99.     # Stop when the timeout limit is reached (see -t above).
  100.     until &time > timeout & /first_time do {
  101.  
  102.     first_time := &null
  103.     wordlist := copy(master_list); rejects := list()
  104.     puzzle := list(height); every !puzzle := list(width)
  105.     blind_luck_insert(puzzle, wordlist, rejects)
  106.     brute_force_insert(puzzle, wordlist, rejects, timeout)
  107.  
  108.     # Count the number of letters left over.
  109.     no_ltrs := 0; every no_ltrs +:= *(!wordlist | !rejects)
  110.     l_no_ltrs := 0; every l_no_ltrs +:= *(!\l_wordlist | !\l_rejects)
  111.     # If our last best try at making a puzzle was worse...
  112.     if /l_puzzle |
  113.         (*\l_wordlist + *l_rejects) > (*wordlist + *rejects) |
  114.         ((*\l_wordlist + *l_rejects) = (*wordlist + *rejects) &
  115.          l_no_ltrs > no_ltrs)
  116.     then {
  117.         # ...then save the current (better) one.
  118.         l_puzzle   := puzzle
  119.         l_wordlist := wordlist
  120.         l_rejects  := rejects
  121.     }
  122.  
  123.     # Tell the user how we're doing.
  124.     if \_debug_ then
  125.         write(&errout, "makepuzz:  try number ", try +:= 1, "; ",
  126.           *wordlist + *rejects, " rejects")
  127.  
  128.     # See the -r argument above.  Stop if we get to a number of
  129.     # rejects deemed acceptable to the user.
  130.     if (*\l_wordlist + *l_rejects) <= maxrejects then break
  131.     }
  132.  
  133.     # Signal to user that we're done, and set puzzle, wordlist, and
  134.     # rejects to their best values in this run of makepuzz.
  135.     write(&errout, "makepuzz:  done")
  136.     puzzle   := \l_puzzle
  137.     wordlist := \l_wordlist
  138.     rejects  := \l_rejects
  139.  
  140.     # Print out original word list, and list of words that didn't make
  141.     # it into the puzzle.
  142.     write(outputfile, "Original word list (sorted hardest-to-easiest): \n")
  143.     every write(outputfile, colmize(master_list))
  144.     write(outputfile, "")
  145.     if *rejects + *wordlist > 0 then {
  146.     write(outputfile, "Couldn't insert the following words: \n")
  147.     every write(outputfile, colmize(wordlist ||| rejects))
  148.     write(outputfile, "")
  149.     }
  150.  
  151.     # Scramble (i.e. put in letters for remaining spaces) if the user
  152.     # put -s on the command line.
  153.     if \opttbl["s"] then {
  154.     every y := !puzzle do
  155.         every x := 1 to *y do
  156.             /y[x] := ?&ucase
  157.  
  158.         # Print out puzzle structure (answers in lowercase).
  159.     every y := !puzzle do {
  160.         every x := !y do
  161.         writes(outputfile, \x | " ", " ")
  162.         write(outputfile, "")
  163.     }
  164.     write(outputfile, "")
  165.     }
  166.  
  167.     # Print out puzzle structure, all lowercase.
  168.     every y := !puzzle do {
  169.     every x := !y do
  170.         writes(outputfile, map(\x) | " ", " ")
  171.         write(outputfile, "")
  172.     }
  173.  
  174.     # Exit with default OK status for this system.
  175.     every close(inputfile | outputfile)
  176.     exit()
  177.  
  178. end
  179.  
  180.  
  181. procedure sort_words(wordlist)
  182.  
  183.     local t, t2, word, sum, l
  184.  
  185.     # Obtain a rough character count.
  186.     t := table(0)
  187.     every t[!!wordlist] +:= 1
  188.     t2 := table()
  189.  
  190.     # Obtain weighted values for each word, essentially giving longer
  191.     # words and words with uncommon letters the highest values.  Later
  192.     # we'll reverse the order (-> hardest-to-easiest), and return a list.
  193.     every word := !wordlist do {
  194.     "" == word & next
  195.     sum := 0
  196.     every sum +:= t[!word]
  197.     insert(t2, word, (sum / *word) - (2 * *word))
  198.     }
  199.     t2 := sort(t2, 4)
  200.     l := list()
  201.  
  202.     # Put the hardest words first.  These will get laid down when the
  203.     # puzzle is relatively empty.  Save the small, easy words for last.
  204.     every put(l, t2[1 to *t2-1 by 2])
  205.     return l
  206.  
  207. end
  208.  
  209.  
  210. procedure blind_luck_insert(puzzle, wordlist, rejects)
  211.  
  212.     local s, s2, s3, begy, begx, y, x, diry, dirx, diry2, dirx2, i
  213.     # global height, width
  214.  
  215.     # Try using blind luck to make as many insertions as possible.
  216.     while s := get(wordlist) do {
  217.  
  218.     # First try squares with letters already on them, but don't
  219.     # try every direction yet (we're relying on luck just now).
  220.     # Start at a random spot in the puzzle, and wrap around.
  221.     begy := ?height; begx := ?width
  222.     every y := (begy to height) | (1 to begy - 1) do {
  223.         every x := (begx to width) | (1 to begx - 1) do  {
  224.         every i := find(\puzzle[y][x], s) do {
  225.             diry := ?3; dirx := ?3
  226.             s2 := s[i:0]
  227.             diry2 := 4 > (diry + 2) | 0 < (diry - 2) | 2
  228.             dirx2 := 4 > (dirx + 2) | 0 < (dirx - 2) | 2
  229.             s3 := reverse(s[1:i+1])
  230.             if insert_word(puzzle, s2, diry, dirx, y, x) &
  231.             insert_word(puzzle, s3, diry2, dirx2, y, x)
  232.             then break { break break next }
  233.         }
  234.         }
  235.     }
  236.  
  237.     # If the above didn't work, give up on spaces with characters
  238.     # in them; use blank squares as well.
  239.     every 1 to 512 do
  240.         if insert_word(puzzle, s, ?3, ?3, ?height, ?width) then
  241.            break next
  242.     # If this word doesn't submit to easy insertion, save it for
  243.     # later.
  244.     put(rejects, s)
  245.     }
  246.  
  247.     # Nothing useful to return (puzzle, wordlist, and rejects objects
  248.     # are themselves modified; not copies of them).
  249.     return
  250.  
  251. end
  252.  
  253.  
  254. procedure brute_force_insert(puzzle, wordlist, rejects, timeout)
  255.  
  256.     local s, start, dirs, begy, begx, y, x
  257.     
  258.     # Use brute force on the remaining forms.
  259.     if *rejects > 0 then {
  260.     wordlist |||:= rejects; rejects := []
  261.     while s := pop(wordlist) do {
  262.         start := ?3; dirs := ""
  263.         every dirs ||:= ((start to 3) | (1 to start-1))
  264.         begy := ?height; begx := ?width
  265.         every y := (begy to height) | (1 to begy - 1) do {
  266.         if &time > timeout then fail
  267.         every x := (begx to width) | (1 to begx - 1) do  {
  268.             if insert_word(puzzle, s, !dirs, !dirs, y, x) then
  269.             break { break next }
  270.         }
  271.         }
  272.         # If we can't find a place for s, put it in the rejects list.
  273.         put(rejects, s)
  274.     }
  275.     }
  276.  
  277.     # Nothing useful to return (puzzle, wordlist, and rejects objects
  278.     # are themselves modified; not copies of them).
  279.     return
  280.  
  281. end
  282.  
  283.  
  284. procedure insert_word(puzzle, s, ydir, xdir, y, x)
  285.  
  286.     local incry, incrx, firstchar
  287.  
  288.     # If s is zero length, we've matched it in it's entirety!
  289.     if *s = 0 then {
  290.     return
  291.  
  292.     } else {
  293.  
  294.     # Make sure there's enough space in the puzzle in the direction
  295.     # we're headed.
  296.     case ydir of {
  297.         "3":  if (height - y) < (*s - 1) then fail
  298.         "1":  if y < (*s - 1) then fail
  299.     }
  300.     case xdir of {
  301.         "3":  if (width - x) < (*s - 1) then fail
  302.         "1":  if x < (*s - 1) then fail
  303.     }
  304.  
  305.     # Check to be sure everything's in range, and that both the x and
  306.     # y increments aren't zero (in which case, we aren't headed in any
  307.     # direction at all...).
  308.     incry := (ydir - 2); incrx := (xdir - 2)
  309.     if incry = 0 & incrx = 0 then fail
  310.     height >= y >= 1 | fail
  311.     width >= x >= 1 | fail
  312.  
  313.     # Try laying the first char in s down at puzzle[y][x].  If it
  314.     # works, head off in some direction, and try laying down the rest
  315.     # of s along that vector.  If at any point we fail, we must
  316.     # reverse the assignment (<- below).
  317.     firstchar := !s
  318.     ((/puzzle[y][x] <- firstchar) | (\puzzle[y][x] == firstchar)) &
  319.         insert_word(puzzle, s[2:0], ydir, xdir, y + incry, x + incrx) &
  320.         suspend
  321.     fail
  322.     }
  323.  
  324. end
  325.